home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
BBS-Archive
/
Dev
/
Obrn-A_1.6_lib.lha
/
oberon-a
/
source3.lha
/
source
/
Library
/
Files.mod
< prev
next >
Wrap
Text File
|
1995-06-29
|
16KB
|
702 lines
(*************************************************************************
$RCSfile: Files.mod $
Description: Operations on files and the file directory.
Created by: fjc (Frank Copeland)
$Revision: 1.13 $
$Author: fjc $
$Date: 1995/06/04 23:22:41 $
Copyright © 1994-1995, Frank Copeland.
This file is part of the Oberon-A Library.
See Oberon-A.doc for conditions of use and distribution.
*************************************************************************)
<* STANDARD- *>
MODULE Files;
IMPORT
SYS := SYSTEM, Kernel, e := Exec, d := Dos, du := DosUtil,
str := Strings, conv := Conversions, oc := OberonClock;
CONST
SectorSize = 1024;
MaxBufs = 4;
TYPE
File *= POINTER TO Handle;
Buffer = POINTER TO BufferRecord;
Rider *= RECORD
eof -: BOOLEAN;
res -: LONGINT;
file : File;
pos : LONGINT;
buf : Buffer;
bpos : INTEGER;
END; (* Rider *)
Handle = RECORD
fl -: d.FileLockPtr;
fh -: d.FileHandlePtr;
name : ARRAY 256 OF CHAR;
tempNo : LONGINT;
pos, len : LONGINT;
nofbufs : INTEGER;
next : File;
firstbuf : Buffer;
END; (* Handle *)
DataSector = ARRAY SectorSize OF SYS.BYTE;
BufferRecord = RECORD
apos : LONGINT;
lim : INTEGER;
mod : BOOLEAN;
next : Buffer;
data : DataSector;
END; (* BufferRecord *)
VAR
root : File;
tempNo : LONGINT;
CONST
tempExt = ".tmp";
bkpExt = ".bkp";
PROCEDURE GetTempNo;
VAR time, date : LONGINT;
BEGIN (* GetTempNo *)
oc.GetClock (time, date);
tempNo := ABS ((date * 10000H + time) DIV 2)
END GetTempNo;
PROCEDURE MakeName
( name : ARRAY OF CHAR;
tempNo : LONGINT;
ext : ARRAY OF CHAR;
VAR tempName : ARRAY OF CHAR );
VAR pathPart : e.LSTRPTR; s : ARRAY 13 OF CHAR;
<*$CopyArrays-*>
BEGIN (* MakeName *)
COPY (name, tempName);
IF tempName # "" THEN
pathPart := d.PathPart (tempName); pathPart [0] := 0X
END;
ASSERT (conv.IntToStr (tempNo, 16, 0, "0", s));
str.Append (ext, s);
ASSERT (d.AddPart (tempName, s, LEN (tempName)))
END MakeName;
PROCEDURE Search ( fl : d.FileLockPtr ) : File;
VAR f : File;
BEGIN (* Search *)
f := root;
WHILE (f # NIL) & (d.SameLock (fl, f.fl) # d.same) DO f := f.next END;
RETURN f
END Search;
PROCEDURE Unlink (f : File);
VAR f0 : File;
BEGIN (* Unlink *)
IF root # NIL THEN
IF f = root THEN
root := root.next
ELSE
f0 := root;
WHILE (f0.next # NIL) & (f0.next # f) DO
f0 := f0.next
END;
IF f0.next = f THEN f0.next := f.next END;
END
END;
f.next := NIL
END Unlink;
PROCEDURE ReadBuf (f : File; buf : Buffer; pos : LONGINT);
VAR res : LONGINT;
BEGIN (* ReadBuf *)
res := d.Seek (f.fh, pos, d.beginning);
IF res # -1 THEN
buf.lim := SHORT (d.Read (f^.fh, buf.data, SectorSize));
buf.apos := pos;
buf.mod := FALSE;
END
END ReadBuf;
PROCEDURE WriteBuf (f : File; buf : Buffer);
VAR res : LONGINT;
BEGIN (* WriteBuf *)
res := d.Seek (f.fh, buf.apos, d.beginning);
IF res # -1 THEN
res := d.Write (f.fh, buf.data, buf.lim);
IF res = buf.lim THEN
buf.mod := FALSE;
END
END
END WriteBuf;
PROCEDURE GetBuf (f : File; pos : LONGINT) : Buffer;
VAR buf, last, next : Buffer;
BEGIN (* GetBuf *)
buf := f.firstbuf;
LOOP
IF buf.apos = pos THEN EXIT END;
IF buf.next = f.firstbuf THEN
last := buf;
IF f.nofbufs < MaxBufs THEN (* allocate new buffer *)
NEW (buf); INC (f.nofbufs);
ELSE (* take one of the buffers (assuming more than one) *)
buf := f.firstbuf; f.firstbuf := buf.next; last.next := buf.next;
IF buf.mod THEN WriteBuf (f, buf) END
END;
IF pos < f.firstbuf.apos THEN
f.firstbuf := buf
ELSIF pos < last.apos THEN
WHILE last.next.apos < pos DO last := last.next END;
END;
buf.next := last.next; last.next := buf;
buf.apos := pos; buf.lim := 0; buf.mod := FALSE;
IF pos < f.len THEN ReadBuf (f, buf, pos) END;
EXIT
END;
buf := buf.next
END; (* LOOP *)
RETURN buf;
END GetBuf;
PROCEDURE Unbuffer (f : File);
VAR buf : Buffer;
BEGIN (* Unbuffer *)
buf := f.firstbuf;
REPEAT
IF buf.mod THEN WriteBuf (f, buf) END;
buf := buf.next
UNTIL buf = f.firstbuf
END Unbuffer;
PROCEDURE Delete * ( name : ARRAY OF CHAR; VAR res : INTEGER );
<*$CopyArrays-*>
BEGIN (* Delete *)
IF d.DeleteFile (name) THEN
res := 0
ELSE
res := SHORT (d.IoErr ());
IF res = d.objectNotFound THEN res := 0 END
END
END Delete;
PROCEDURE Rename * ( old, new : ARRAY OF CHAR; VAR res : INTEGER );
<*$CopyArrays-*>
BEGIN (* Rename *)
IF d.Rename (old, new) THEN res := 0
ELSE res := SHORT (d.IoErr ())
END
END Rename;
PROCEDURE Old * ( name : ARRAY OF CHAR ) : File;
VAR
f : File; fl : d.FileLockPtr; fh : d.FileHandlePtr;
fib : d.FileInfoBlockPtr; len : LONGINT; buf : Buffer;
<*$CopyArrays-*>
BEGIN (* Old *)
fl := d.Lock (name, d.sharedLock);
IF fl # NIL THEN
f := Search (fl);
IF f = NIL THEN
fh := d.Open (name, d.oldFile);
IF fh # NIL THEN
fib := d.AllocDosObjectTags (d.fib, NIL);
IF fib # NIL THEN
IF d.Examine (fl, fib^) THEN len := fib.size;
ELSE len := 0
END;
d.FreeDosObject (d.fib, fib);
NEW (f);
IF f # NIL THEN
NEW (buf);
IF buf # NIL THEN
buf.apos := 0; buf.next := buf; buf.mod := FALSE;
IF len > SectorSize THEN buf.lim := SectorSize
ELSE buf.lim := SHORT (len)
END;
f.len := len; f.firstbuf := buf; f.nofbufs := 1;
COPY (name, f.name); f.tempNo := 0;
f.fl := fl; f.fh := fh; f.pos := 0;
f.next := root; root := f;
ReadBuf (f, buf, 0);
RETURN f
END;
END;
END;
END;
d.OldClose (fh)
END;
d.UnLock (fl)
END;
RETURN f
END Old;
PROCEDURE New * ( name : ARRAY OF CHAR ) : File;
VAR
f : File; fl : d.FileLockPtr; fh : d.FileHandlePtr;
buf : Buffer; tempName : ARRAY 256 OF CHAR;
<*$CopyArrays-*>
BEGIN (* New *)
REPEAT
IF tempNo < MAX (LONGINT) THEN INC (tempNo) ELSE tempNo := 1 END;
MakeName (name, tempNo, tempExt, tempName)
UNTIL ~du.FileExists (tempName);
fh := d.Open (tempName, d.newFile);
IF fh # NIL THEN
NEW (f);
IF f # NIL THEN
NEW (buf);
IF buf # NIL THEN
buf.apos := 0; buf.next := buf; buf.mod := TRUE;
buf.lim := 0;
f.len := 0; f.firstbuf := buf; f.nofbufs := 1;
COPY (name, f.name); f.tempNo := tempNo;
f.fl := d.Lock (tempName, d.sharedLock); f.fh := fh; f.pos := 0;
f.next := root; root := f;
ReadBuf (f, buf, 0);
RETURN f
END
END
END;
d.OldClose (fh);
RETURN f
END New;
PROCEDURE Register * ( f : File );
VAR tempName, bkpName : ARRAY 256 OF CHAR; res : INTEGER;
BEGIN (* Register *)
ASSERT (f # NIL, 97);
IF f.fh # NIL THEN
Unbuffer (f); Unlink (f);
IF d.Close (f.fh) THEN
f.fh := NIL; d.UnLock (f.fl); f.fl := NIL;
IF f.tempNo # 0 THEN
MakeName (f.name, f.tempNo, tempExt, tempName);
IF f.name = "" THEN
Delete (tempName, res);
ELSE
MakeName (f.name, f.tempNo, bkpExt, bkpName);
Rename (f.name, bkpName, res);
IF res = 0 THEN
Rename (tempName, f.name, res);
IF res = 0 THEN Delete (bkpName, res) END
ELSIF res = d.objectNotFound THEN
Rename (tempName, f.name, res);
END
END
END
END
END
END Register;
PROCEDURE Close * ( f : File );
BEGIN (* Close *)
ASSERT (f # NIL, 97);
IF f.fh # NIL THEN
Unbuffer (f); Unlink (f);
IF d.Close (f.fh) THEN f.fh := NIL; d.UnLock (f.fl); f.fl := NIL END
END
END Close;
PROCEDURE Purge * ( f : File );
VAR tempName : ARRAY 256 OF CHAR; res : INTEGER;
BEGIN (* Purge *)
ASSERT (f # NIL, 97);
IF f.fh # NIL THEN
Unbuffer (f); Unlink (f);
IF d.Close (f.fh) THEN f.fh := NIL; d.UnLock (f.fl); f.fl := NIL END;
IF f.tempNo # 0 THEN
MakeName (f.name, f.tempNo, tempExt, tempName);
Delete (tempName, res)
END
END
END Purge;
PROCEDURE Length * ( f : File ) : LONGINT;
BEGIN (* Length *)
ASSERT (f # NIL, 97);
RETURN f.len
END Length;
PROCEDURE GetDate * ( f : File; VAR time, day : LONGINT );
VAR fib : d.FileInfoBlockPtr;
BEGIN (* GetDate *)
ASSERT (f # NIL, 97); ASSERT (f.fh # NIL, 97);
fib := d.AllocDosObjectTags (d.fib, NIL);
IF fib # NIL THEN
IF d.ExamineFH (f.fh, fib^) THEN
oc.ADOS2OberonTime (fib.date, time, day);
END;
d.FreeDosObject (d.fib, fib)
END
END GetDate;
PROCEDURE Set * ( VAR r : Rider; f : File; pos : LONGINT );
BEGIN (* Set *)
r.eof := FALSE; r.res := 0; r.file := f;
IF f # NIL THEN
IF pos < 0 THEN r.pos := 0; r.bpos := 0
ELSE r.bpos := SHORT (pos MOD SectorSize); r.pos := pos - r.bpos
END;
r.buf := f.firstbuf
END
END Set;
PROCEDURE Pos * ( VAR r : Rider ) : LONGINT;
BEGIN (* Pos *)
RETURN r.pos + r.bpos
END Pos;
PROCEDURE Base * ( VAR r : Rider ) : File;
BEGIN (* Base *)
RETURN r.file
END Base;
PROCEDURE Read * ( VAR r : Rider; VAR x : SYS.BYTE );
VAR buf : Buffer;
BEGIN (* Read *)
ASSERT (r.file # NIL, 97);
IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
IF r.bpos < r.buf.lim THEN
x := r.buf.data [r.bpos]; INC (r.bpos)
ELSIF (r.pos + SectorSize) < r.file.len THEN
INC (r.pos, SectorSize);
r.buf := GetBuf (r.file, r.pos);
x := r.buf.data [0]; r.bpos := 1
ELSE
x := 0X; r.eof := TRUE
END
END Read;
PROCEDURE ReadBytes * ( VAR r : Rider; VAR x : ARRAY OF SYS.BYTE;
n : LONGINT );
VAR src, dst, m : LONGINT;
buf : Buffer;
BEGIN (* ReadBytes *)
ASSERT (r.file # NIL, 97); ASSERT (r.file.fh # NIL, 97);
ASSERT (LEN (x) >= n, 97);
dst := SYS.VAL (LONGINT, SYS.ADR (x));
IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
LOOP
IF n <= 0 THEN EXIT END;
src := SYS.VAL (LONGINT, SYS.ADR(r.buf.data));
INC (src, r.bpos); m := r.bpos + n;
IF m <= r.buf.lim THEN
SYS.MOVE (src, dst, n); r.bpos := SHORT (m); r.res := 0;
EXIT
ELSIF r.buf.lim = SectorSize THEN
m := r.buf.lim - r.bpos;
IF m > 0 THEN
SYS.MOVE (src, dst, m); INC (dst, m); DEC (n, m)
END;
IF r.pos < r.file.len THEN
INC (r.pos, SectorSize);
r.bpos := 0; r.buf := GetBuf (r.file, r.pos);
ELSE
r.res := n; r.eof := TRUE; EXIT
END;
ELSE
m := r.buf.lim - r.bpos;
IF m > 0 THEN
SYS.MOVE (src, dst, m); r.bpos := r.buf.lim
END;
r.res := n - m; r.eof := TRUE; EXIT
END;
END; (* LOOP *)
END ReadBytes;
<*$ < StackChk- IndexChk- *>
PROCEDURE SwapWord ( VAR w : ARRAY OF SYS.BYTE );
VAR t : SYS.BYTE;
BEGIN (* SwapWord *)
t := w [0]; w [0] := w [1]; w [1] := t
END SwapWord;
PROCEDURE SwapLongword ( VAR l : ARRAY OF SYS.BYTE );
VAR t : SYS.BYTE;
BEGIN (* SwapLongword *)
t := l [0]; l [0] := l [3]; l [3] := t;
t := l [1]; l [1] := l [2]; l [2] := t;
END SwapLongword;
<*$ > *>
PROCEDURE ReadInt * ( VAR r : Rider; VAR x : INTEGER );
VAR i : INTEGER;
BEGIN (* ReadInt *)
ReadBytes (r, i, 2); SwapWord (i); x := i
END ReadInt;
PROCEDURE ReadLInt * ( VAR r : Rider; VAR x : LONGINT );
VAR i : LONGINT;
BEGIN (* ReadLInt *)
ReadBytes (r, i, 4); SwapLongword (i); x := i
END ReadLInt;
PROCEDURE ReadReal * ( VAR r : Rider; VAR x : REAL );
VAR y : REAL;
BEGIN (* ReadReal *)
ReadBytes (r, y, 4); SwapLongword (y); x := y
END ReadReal;
PROCEDURE ReadLReal * ( VAR r : Rider; VAR x : LONGREAL );
BEGIN (* ReadLReal *)
HALT (99)
END ReadLReal;
PROCEDURE ReadNum * ( VAR r : Rider; VAR x : LONGINT );
VAR s : SHORTINT; ch : CHAR; n : LONGINT;
BEGIN (* ReadNum *)
s := 0; n := 0; Read(r, ch);
WHILE ORD(ch) >= 128 DO
INC(n, ASH(ORD(ch) - 128, s)); INC(s, 7); Read(r, ch)
END;
x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
END ReadNum;
PROCEDURE ReadString * ( VAR r : Rider; VAR x : ARRAY OF CHAR );
VAR ch : CHAR; i : INTEGER;
BEGIN (* ReadString *)
i := 0;
REPEAT
Read (r, ch); x [i] := ch; INC (i)
UNTIL ch = 0X
END ReadString;
PROCEDURE ReadSet * ( VAR r : Rider; VAR x : SET );
VAR s : SET;
BEGIN (* ReadSet *)
ReadBytes (r, s, 4); SwapLongword (s); x := s
END ReadSet;
PROCEDURE ReadBool * ( VAR r : Rider; VAR x : BOOLEAN );
VAR i : SHORTINT;
BEGIN (* ReadBool *)
Read (r, i); x := (i # 0)
END ReadBool;
PROCEDURE Write * ( VAR r : Rider; x : SYS.BYTE );
VAR f : File; buf : Buffer;
BEGIN (* Write *)
ASSERT (r.file # NIL, 97); ASSERT (r.file.fh # NIL, 97);
IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
IF r.bpos >= r.buf.lim THEN
IF r.bpos < SectorSize THEN
INC (r.buf.lim); INC (r.file.len)
ELSE
f := r.file; INC (r.pos, SectorSize);
r.buf := GetBuf (f, r.pos);
IF r.pos >= f.len THEN r.buf.lim := 1; f.len := r.pos END;
r.bpos := 0
END
END;
r.buf.data [r.bpos] := x; INC (r.bpos); r.buf.mod := TRUE
END Write;
PROCEDURE WriteBytes * ( VAR r : Rider; VAR x : ARRAY OF SYS.BYTE;
n : LONGINT );
VAR src, dst, m : LONGINT; f : File; buf : Buffer;
BEGIN (* WriteBytes *)
ASSERT (r.file # NIL, 97); ASSERT (r.file.fh # NIL, 97);
ASSERT (LEN (x) >= n, 97);
src := SYS.VAL (LONGINT, SYS.ADR (x));
IF r.pos # r.buf.apos THEN r.buf := GetBuf (r.file, r.pos) END;
LOOP
IF n <= 0 THEN EXIT END;
r.buf.mod := TRUE;
dst := SYS.VAL (LONGINT, SYS.ADR(r.buf.data)); INC (dst, r.bpos);
m := r.bpos + n;
IF m <= r.buf.lim THEN
SYS.MOVE (src, dst, n); r.bpos := SHORT (m); EXIT
ELSIF m <= SectorSize THEN
SYS.MOVE (src, dst, n); r.bpos := SHORT (m);
INC (r.file.len, n); r.buf.lim := SHORT (m); EXIT
ELSE
m := SectorSize - r.bpos;
IF m > 0 THEN
SYS.MOVE (src, dst, m); INC (src, m); DEC (n, m);
INC (r.buf.lim, SHORT (m))
END;
f := r.file; INC (r.pos, SectorSize);
r.bpos := 0; r.buf := GetBuf (f, r.pos);
IF r.pos >= f.len THEN r.buf.lim := 0; f.len := r.pos END;
END;
END; (* LOOP *)
END WriteBytes;
PROCEDURE WriteInt * ( VAR r : Rider; x : INTEGER );
BEGIN (* WriteInt *)
SwapWord (x); WriteBytes (r, x, 2);
END WriteInt;
PROCEDURE WriteLInt * ( VAR r : Rider; x : LONGINT );
BEGIN (* WriteLInt *)
SwapLongword (x); WriteBytes (r, x, 4);
END WriteLInt;
PROCEDURE WriteReal * ( VAR r : Rider; x : REAL );
BEGIN (* WriteReal *)
SwapLongword (x); WriteBytes (r, x, 4);
END WriteReal;
PROCEDURE WriteLReal * ( VAR r : Rider; x : LONGREAL );
BEGIN (* WriteLReal *)
HALT (99)
END WriteLReal;
PROCEDURE WriteNum * ( VAR r : Rider; x : LONGINT );
BEGIN (* WriteNum *)
WHILE (x < -64) OR (x > 63) DO
Write(r, CHR(x MOD 128 + 128)); x := x DIV 128
END;
Write(r, CHR(x MOD 128))
END WriteNum;
PROCEDURE WriteString * ( VAR r : Rider; x : ARRAY OF CHAR );
<*$CopyArrays-*>
BEGIN (* WriteString *)
WriteBytes (r, x, str.Length (x)); Write (r, 0X)
END WriteString;
PROCEDURE WriteSet * ( VAR r : Rider; x : SET );
BEGIN (* WriteSet *)
SwapLongword (x); WriteBytes (r, x, 4);
END WriteSet;
PROCEDURE WriteBool * ( VAR r : Rider; x : BOOLEAN );
VAR i : SHORTINT;
BEGIN (* WriteBool *)
IF x THEN i := 1 ELSE i := 0 END; Write (r, i)
END WriteBool;
PROCEDURE* CloseFiles ( VAR rc : LONGINT );
BEGIN (* CloseFiles *)
WHILE root # NIL DO
IF root.fh # NIL THEN
Unbuffer (root);
IF d.Close (root.fh) THEN END;
d.UnLock (root.fl);
END;
root := root.next
END;
END CloseFiles;
BEGIN (* Files *)
root := NIL; GetTempNo; Kernel.SetCleanup (CloseFiles);
END Files.